Methods

library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)
library(brms)

df <- read.csv("data/data.csv") |>
  mutate(
    Date = lubridate::dmy(Date),
    Participant = fct_reorder(Participant, Date),
    Screen_Refresh = as.character(Screen_Refresh),
    Education = fct_relevel(Education, "Doctorate", "Master", "Bachelor", "High School", "Other", "Prefer not to Say"),
    Belief = fct_relevel(Belief, "Fake", "Real"),
    Stimulus_Interest = case_when(
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Opposite" ~ TRUE,
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Same" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Opposite" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Same" ~ TRUE,
      Sexual_Orientation %in% c("Bisexual", "Queer", "Pansexual") ~ TRUE,
      TRUE ~ NA
    )
  )


# head(df[is.na(df$Stimulus_Attract), ])

# Create individual scores for Simulation Monitoring
df <- df |>
  group_by(Participant, Belief) |>
  summarise(
    Confidence = mean(abs(Belief_Confidence)),
    n = n() / 109
  ) |>
  pivot_wider(names_from = "Belief", values_from = c("Confidence", "n")) |>
  ungroup() |>
  merge(df, by = "Participant")

Exclusions

outliers <- c(
  # Very short duration for questionnaire in particular + low rating correlations
  "5eaef8702b68455d6e130595_ptsga",
  "5f0f0a2a8b2a480447f31b21_lqgpz",
  "611d03b822d4c8e041ea0c32_m0knb",
  # Prefered not answering to sexual orientation: further analysis impossible
  "60eb34f117838a34a29a69d3_rxv85"
)
outliers_partial <- c(
  "5dc3485219ca0326027ce91f_37ho9",
  "5c6414540821d30001046198_x9q7r",
  "60dd7b03f1e72d38230df476_9yh9n",
  "5962799cb752840001ca478b_jh4sl",
  "5f44c23fbf2ddb80bcdf0edc_dnbny",
  "5e80370d48b5f47170e30e5c_5w2gf"
)

We removed 4 participants based on failed attention checks.

Extreme Items

extreme_items <- df |>
  group_by(Stimulus, Belief) |>
  summarize(n = n() / length(unique(df$Participant))) |>
  pivot_wider(values_from = "n", names_from = "Belief") |>
  mutate(File = paste0("experiment/stimuli/AMFD/", Stimulus)) |>
  arrange(Real) |>
  filter(Real < 0.15 | Real > 0.85)


p_item <- df |>
  filter(Stimulus %in% extreme_items$Stimulus) |>
  mutate(Stimulus = fct_relevel(Stimulus, as.character(extreme_items$Stimulus))) |>
  ggplot(aes(x = Belief_Answer, y = Stimulus, fill = Stimulus)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups") +
  geom_vline(xintercept = 0, linetype = "dotted") +
  ggimage::geom_image(data = extreme_items, aes(image = File, x = 0, y = Stimulus), size = 0.1, by = "height") +
  # scale_y_discrete(expand = c(0.5, 0.5)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-1, 0, 1),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d(option = "inferno") +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    # axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )
# p_item


df <- df |>
  filter(!Stimulus %in% extreme_items$Stimulus)

extreme_items
## # A tibble: 1 × 4
## # Groups:   Stimulus [1]
##   Stimulus     Fake  Real File                               
##   <chr>       <dbl> <dbl> <chr>                              
## 1 NF-1071.jpg 0.887 0.113 experiment/stimuli/AMFD/NF-1071.jpg

We removed 1 trials per participant.

Attention Checks and Duration

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, starts_with("Attention"), starts_with("Duration"), n_Fake) |>
  slice(1) |>
  ungroup() |>
  rowwise() |>
  mutate(Attention_Check = mean(c(Attention_Check1, Attention_Check2, Attention_Check3))) |>
  ungroup() |>
  arrange(Attention_Check)

Ratings

dfsub$r_Trustworthy <- NA
dfsub$r_Attractive <- NA
dfsub$r_Beauty <- NA
for (participant in dfsub$Participant) {
  dfsub[dfsub$Participant == participant, "r_Trustworthy"] <- cor(df[df$Participant == participant, "Trustworthy"], df[df$Participant == participant, "Norms_Trustworthy"])
  dfsub[dfsub$Participant == participant, "r_Attractive"] <- cor(df[df$Participant == participant, "Attractive"], df[df$Participant == participant, "Norms_Attractive"])
  dfsub[dfsub$Participant == participant, "r_Beauty"] <- cor(df[df$Participant == participant, "Beauty"], df[df$Participant == participant, "Norms_Attractive"])
}

Summary

data.frame(Participant = c(paste0("Total (n=", nrow(dfsub), ")")), t(sapply(dfsub[2:ncol(dfsub)], mean, na.rm = TRUE))) |>
  rbind(dfsub) |>
  mutate(Attention_Check = paste0(
    insight::format_value(Attention_Check, 1),
    " (", insight::format_value(Attention_Check1, 1),
    ", ",
    insight::format_value(Attention_Check2, 1),
    ", ",
    insight::format_value(Attention_Check3, 1),
    ")"
  )) |>
  select(-Attention_Check1, -Attention_Check2, -Attention_Check3) |>
  datawizard::data_relocate("Attention_Check", 2) |>
  knitr::kable() |>
  kableExtra::row_spec(1, italic = TRUE) |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers) + 1, background = "#EF9A9A") |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers_partial) + 1, background = "#FFCC80")  |> 
  kableExtra::kable_styling(full_width = TRUE) |> 
  kableExtra::scroll_box(width = "100%", height = "500px")
Participant Attention_Check Duration_Questionnaires Duration_Task n_Fake r_Trustworthy r_Attractive r_Beauty
Total (n=150) 1.0 (1.0, 1.0, 1.0) 12.18 23.8 0.442 0.273 0.435 0.457
611d03b822d4c8e041ea0c32_m0knb 0.6 (0.6, 0.4, 0.6) 6.00 20.5 0.248 0.164 0.208 0.225
5f0f0a2a8b2a480447f31b21_lqgpz 0.6 (0.2, 1.0, 0.5) 164.70 17.6 0.642 -0.144 0.343 0.288
5962799cb752840001ca478b_jh4sl 0.7 (1.0, 0.2, 1.0) 19.93 30.4 0.284 0.063 0.344 0.326
5dc3485219ca0326027ce91f_37ho9 0.8 (0.5, 1.0, 1.0) 7.01 16.1 0.587 0.253 0.572 0.557
5c6414540821d30001046198_x9q7r 0.9 (1.0, 1.0, 0.6) 9.84 23.4 0.284 0.330 0.483 0.466
60dd7b03f1e72d38230df476_9yh9n 0.9 (0.6, 1.0, 1.0) 12.86 19.9 0.092 0.435 0.429 0.550
5f44c23fbf2ddb80bcdf0edc_dnbny 0.9 (0.7, 1.0, 1.0) 4.71 24.8 0.486 0.103 0.147 0.195
5e80370d48b5f47170e30e5c_5w2gf 0.9 (0.7, 1.0, 1.0) 5.64 22.8 0.440 0.350 0.604 0.612
61356174c090b0083f131e01_asm81 0.9 (0.8, 1.0, 1.0) 9.64 17.5 0.349 0.055 0.081 0.086
60920010e7bfd828a698e5dd_0elu0 0.9 (0.8, 1.0, 1.0) 17.48 27.2 0.404 0.198 0.446 0.480
608ee67f23c2f9f721ddf2a0_bk1h0 1.0 (0.9, 1.0, 1.0) 18.95 19.4 0.477 0.356 0.481 0.448
5fb7cfde7808523cea8ee891_xlrlw 1.0 (0.9, 1.0, 1.0) 6.95 17.7 0.514 0.324 0.515 0.532
613aa96038862e4f29605ade_as7q6 1.0 (0.9, 1.0, 1.0) 14.12 21.6 0.532 0.483 0.287 0.312
613e4bf960ca68f8de00e5e7_cfsdt 1.0 (0.9, 1.0, 1.0) 11.15 23.8 0.468 0.265 0.466 0.428
6115d9fa61078b29b8db91ff_ewn8c 1.0 (0.9, 1.0, 1.0) 11.06 19.3 0.440 0.452 0.250 0.341
5f1acd8cb55680224c3d452a_56nun 1.0 (0.9, 1.0, 1.0) 11.66 26.0 0.642 0.383 0.527 0.518
62fbf0a70bb3960cd2e5fbc9_2xhgq 1.0 (0.9, 1.0, 1.0) 10.01 21.5 0.505 0.492 0.539 0.653
5b8646582c180900019c9eb7_xt3l6 1.0 (1.0, 1.0, 1.0) 20.16 21.4 0.514 0.308 0.363 0.338
5d936374253d0a0017f32d96_n98qu 1.0 (1.0, 1.0, 1.0) 6.87 13.3 0.440 0.233 0.455 0.457
6075d10e3819fae797f0e3d6_s7lm6 1.0 (1.0, 1.0, 1.0) 12.33 22.9 0.560 0.157 0.264 0.357
611b86fe4bd6db6f42e4afea_4asue 1.0 (1.0, 1.0, 1.0) 17.36 36.8 0.330 0.421 0.279 0.365
613cebea47d2d13a9db63d44_4fbms 1.0 (1.0, 1.0, 1.0) 8.51 26.8 0.468 0.330 0.440 0.628
5f233d7f53212b0e22bf055d_x9368 1.0 (1.0, 1.0, 1.0) 13.32 16.7 0.624 0.430 0.603 0.619
5fb015142942a535524f55fc_u1vq2 1.0 (1.0, 1.0, 1.0) 14.47 18.4 0.624 0.428 0.575 0.598
5d7f8ffae664ab001967d9d3_7mrcg 1.0 (1.0, 1.0, 1.0) 4.83 11.5 0.468 0.306 0.209 0.361
613a92a2dbedc6e7aad89199_thehb 1.0 (1.0, 1.0, 1.0) 10.85 40.0 0.541 0.305 0.462 0.456
5ad63c167f70c10001904bc5_ers7p 1.0 (1.0, 1.0, 1.0) 12.18 25.6 0.413 0.298 0.466 0.521
5bb511c6689fc5000149c703_d9k0p 1.0 (1.0, 1.0, 1.0) 12.56 21.8 0.083 0.405 -0.168 0.351
5d40a12f4994c40001e4b80c_2ytoa 1.0 (1.0, 1.0, 1.0) 13.25 21.8 0.587 0.338 0.609 0.521
5eaef8702b68455d6e130595_ptsga 1.0 (1.0, 1.0, 1.0) 2.69 14.9 0.523 0.021 0.091 0.096
5eb17f5f5b4ec12749a65a24_cmop5 1.0 (1.0, 1.0, 1.0) 11.40 18.9 0.450 0.358 0.362 0.514
5ed8e10d54fe053fbc756c72_zknp4 1.0 (1.0, 1.0, 1.0) 7.63 26.3 0.468 -0.056 0.540 0.444
5f034ecf38c5aa527d056830_2pvm9 1.0 (1.0, 1.0, 1.0) 10.09 19.0 0.339 0.274 0.564 0.539
5f3801b18c88962be7831304_ubcua 1.0 (1.0, 1.0, 1.0) 8.73 16.8 0.330 0.153 0.578 0.558
5faa6cab8ac7a937a5240fcb_xsbot 1.0 (1.0, 1.0, 1.0) 10.20 14.9 0.505 0.153 0.544 0.517
601941db6605160008690742_twd28 1.0 (1.0, 1.0, 1.0) 6.25 13.9 0.578 0.299 0.453 0.444
6036ab8b13ac9c79d7e67e81_ln8ep 1.0 (1.0, 1.0, 1.0) 7.14 13.4 0.651 0.273 0.265 0.312
60a256f83ef6ada5debc47a9_q7wl4 1.0 (1.0, 1.0, 1.0) 6.03 16.0 0.321 0.218 0.520 0.451
60a3a03bc01ba594c9cca88d_v0jdv 1.0 (1.0, 1.0, 1.0) 11.76 30.0 0.495 0.406 0.258 0.410
60b6c415dbda3236ea22455a_dmezs 1.0 (1.0, 1.0, 1.0) 24.73 43.0 0.450 0.263 0.628 0.613
60e1eb72b81681d6c856bd7b_uzbeq 1.0 (1.0, 1.0, 1.0) 8.62 20.8 0.706 0.439 0.631 0.435
60e4b1dcd0eedab1e11019d1_4varz 1.0 (1.0, 1.0, 1.0) 8.61 33.0 0.349 0.191 0.368 0.388
60f3261b934093c881b85cf6_lnoph 1.0 (1.0, 1.0, 1.0) 13.37 27.8 0.450 0.225 0.520 0.575
611b1c9ce8ad1ac6db791065_hwlhj 1.0 (1.0, 1.0, 1.0) 8.57 26.1 0.541 0.364 0.231 0.525
613a972033d79df11a6570de_1u773 1.0 (1.0, 1.0, 1.0) 14.71 26.2 0.450 0.209 0.666 0.635
613baa22050360ec21d4437f_9sac0 1.0 (1.0, 1.0, 1.0) 16.64 17.6 0.688 0.106 0.195 0.178
614f681bacfa57e3d06529ad_qv0u7 1.0 (1.0, 1.0, 1.0) 15.65 30.0 0.404 0.256 0.427 0.417
6160f3629ac70cba36523ff8_zslcv 1.0 (1.0, 1.0, 1.0) 9.14 23.4 0.523 0.366 0.416 0.444
5c00043a6d931200019bcb9b_wnj27 1.0 (1.0, 1.0, 1.0) 20.36 34.7 0.284 0.543 0.582 0.634
5d3f63a92df9f7001bd92a32_oj5t7 1.0 (1.0, 1.0, 1.0) 7.93 20.1 0.523 0.193 0.390 0.431
5db9b910001ffa0188426dca_knhee 1.0 (1.0, 1.0, 1.0) 6.05 25.5 0.596 0.134 0.169 0.148
5ecd37ee75736a068808fa6c_v4ej4 1.0 (1.0, 1.0, 1.0) 10.52 16.0 0.468 0.217 0.612 0.536
5fdfd04b9bf07d83b2e5f780_gtb9u 1.0 (1.0, 1.0, 1.0) 9.30 20.6 0.147 0.222 0.657 0.620
6107133e49bf8db00bd6d389_qkj9f 1.0 (1.0, 1.0, 1.0) 11.38 29.6 0.477 0.366 0.299 0.579
613a69d8ed1c11f70b3d37c7_yu0z2 1.0 (1.0, 1.0, 1.0) 11.16 28.9 0.477 0.235 0.372 0.415
6146385561e8f95ff4f3b5d6_cvm6o 1.0 (1.0, 1.0, 1.0) 9.13 24.9 0.642 0.197 0.405 0.346
614b55e22ff3944a165736bb_cl98h 1.0 (1.0, 1.0, 1.0) 14.66 22.6 0.450 0.441 0.580 0.514
616cb46402d68cdfc6e8c8db_xzyj4 1.0 (1.0, 1.0, 1.0) 4.59 25.4 0.211 0.000 0.217 0.188
6294ce94ea81c4554b141010_u5v5t 1.0 (1.0, 1.0, 1.0) 8.28 18.7 0.339 0.294 0.491 0.461
558fa9dffdf99b7ce2924662_58ffp 1.0 (1.0, 1.0, 1.0) 10.06 34.9 0.624 0.314 0.451 0.470
572b96ba3ab9df000dbb4461_bq660 1.0 (1.0, 1.0, 1.0) 14.16 16.5 0.202 0.059 0.513 0.540
57b8e70f35624400013d690c_boeew 1.0 (1.0, 1.0, 1.0) 5.71 19.7 0.440 0.402 0.550 0.589
59501095c58c85000101dc57_od0ny 1.0 (1.0, 1.0, 1.0) 5.81 26.6 0.541 0.377 0.495 0.458
595bd5c85ae9a80001ce3426_32tr4 1.0 (1.0, 1.0, 1.0) 8.43 19.4 0.413 0.259 0.477 0.549
5a7875355292b80001227f63_uh6o3 1.0 (1.0, 1.0, 1.0) 11.53 24.4 0.450 0.399 0.513 0.474
5baf6705848bbd0001d6fc8a_kahs0 1.0 (1.0, 1.0, 1.0) 12.03 32.5 0.486 0.266 0.482 0.531
5c573e54e9813700018acc31_kv5lw 1.0 (1.0, 1.0, 1.0) 6.72 23.6 0.514 0.342 0.415 0.396
5dbd7193e8add82b72d795f2_8g8wk 1.0 (1.0, 1.0, 1.0) 11.12 22.9 0.266 0.461 0.577 0.624
5de476f9b5b7ff447db5c4aa_chlcj 1.0 (1.0, 1.0, 1.0) 10.25 17.6 0.468 0.307 0.514 0.459
5e7bcff00fb32c0f51fea882_bvbwo 1.0 (1.0, 1.0, 1.0) 15.14 19.2 0.229 0.207 0.485 0.490
5e8dddaf3d1b57068b77b2f2_8ebal 1.0 (1.0, 1.0, 1.0) 12.53 32.1 0.404 0.507 0.540 0.636
5eb170206e577a07e9954c65_csm2p 1.0 (1.0, 1.0, 1.0) 15.61 23.0 0.459 0.477 0.688 0.718
5ece75528f582a08555e0a3e_21ckq 1.0 (1.0, 1.0, 1.0) 13.74 48.5 0.523 0.453 0.500 0.613
5ef0a866cd9cde0fcd0d2f77_rvy90 1.0 (1.0, 1.0, 1.0) 10.57 26.2 0.532 0.200 0.599 0.597
5f09068244f84c18faaa74bc_q0ukp 1.0 (1.0, 1.0, 1.0) 6.97 19.3 0.450 -0.031 0.467 0.496
5f108dea719866356702d26f_p836j 1.0 (1.0, 1.0, 1.0) 5.29 17.4 0.422 -0.226 0.413 0.422
5f49424d243bb347aaec4897_ggzqw 1.0 (1.0, 1.0, 1.0) 8.61 25.3 0.303 0.434 0.518 0.475
5f5e7de4c81d3672642cd612_hpyto 1.0 (1.0, 1.0, 1.0) 7.09 19.1 0.532 0.269 0.524 0.300
5f600669b846780f0fe45709_erd2u 1.0 (1.0, 1.0, 1.0) 13.40 31.0 0.514 0.310 0.587 0.645
5f761e5106b786071f45b4aa_78zle 1.0 (1.0, 1.0, 1.0) 11.56 27.8 0.385 0.048 0.207 0.219
5f7ebad5cf009c196fd54b2b_d68uh 1.0 (1.0, 1.0, 1.0) 8.39 15.6 0.495 0.404 0.674 0.659
5f97e6601f6d0e016087fc91_h6pvt 1.0 (1.0, 1.0, 1.0) 4.71 26.9 0.239 0.051 0.166 0.289
5f9aba6600cdf11f1c9b915c_cakh2 1.0 (1.0, 1.0, 1.0) 26.74 46.8 0.394 0.266 0.325 0.357
5fb633dfaeda3f0aa05eefad_4t92s 1.0 (1.0, 1.0, 1.0) 8.18 18.1 0.505 0.289 0.521 0.499
5ff4a242cbe069bc27d9278b_relyq 1.0 (1.0, 1.0, 1.0) 6.51 14.0 0.183 0.225 0.572 0.540
603f6e643234e512fc197ae1_vowxj 1.0 (1.0, 1.0, 1.0) 11.40 32.7 0.486 0.304 0.538 0.281
6045cb37ffdadc70e734a73b_ns96q 1.0 (1.0, 1.0, 1.0) 17.87 52.2 0.541 0.448 0.427 0.429
604b169fe4b7991ec08da3a6_9o72l 1.0 (1.0, 1.0, 1.0) 7.21 23.4 0.330 0.111 0.456 0.419
605a1c7fe0ca143242990e95_528pg 1.0 (1.0, 1.0, 1.0) 13.97 23.1 0.560 0.388 0.491 0.526
6081728972120aa7f9685791_aqvhb 1.0 (1.0, 1.0, 1.0) 25.43 41.3 0.578 0.312 0.494 0.573
6099df8e57bf74dbc121c774_5jnsc 1.0 (1.0, 1.0, 1.0) 6.22 26.6 0.459 0.510 0.502 0.512
60a6ba026f8bd75b67b23c97_z458q 1.0 (1.0, 1.0, 1.0) 11.75 14.6 0.596 0.241 0.475 0.518
60b8b5dcb46db8ae98d0b047_4u9jy 1.0 (1.0, 1.0, 1.0) 4.86 21.4 0.367 0.151 -0.220 0.445
60cefa69352cbf2549f2bf35_as90e 1.0 (1.0, 1.0, 1.0) 8.50 19.2 0.486 0.513 0.539 0.520
60ddfb3db6a71ad9ba75e387_u85bv 1.0 (1.0, 1.0, 1.0) 8.48 14.7 0.550 0.068 0.502 0.435
61081aab1dad0a92827a371d_bbpfc 1.0 (1.0, 1.0, 1.0) 8.87 21.6 0.486 0.285 0.561 0.532
61093d97f7bf8a4f8117eb82_yzsmx 1.0 (1.0, 1.0, 1.0) 13.15 24.5 0.550 0.122 0.259 0.316
610d97bf0ee9babdb89986ea_3t039 1.0 (1.0, 1.0, 1.0) 8.71 20.4 0.450 0.527 0.584 0.556
61253683f41abc76c81ec082_xc4uu 1.0 (1.0, 1.0, 1.0) 7.45 19.6 0.294 0.346 0.559 0.546
612ba6c594a6d54154a88ae7_m0duf 1.0 (1.0, 1.0, 1.0) 6.73 12.5 0.339 0.513 0.508 0.445
61330f324c6c15a907dc2706_zg72v 1.0 (1.0, 1.0, 1.0) 9.53 28.0 0.404 0.252 0.432 0.495
613af39692992acbacdbbbbc_0g94n 1.0 (1.0, 1.0, 1.0) 17.26 39.3 0.394 0.112 0.458 0.518
6151a21b24b1ef1bc130b97d_cazbl 1.0 (1.0, 1.0, 1.0) 14.07 24.8 0.615 0.050 0.371 0.359
61545919a17f1331cb7b33a7_mszfq 1.0 (1.0, 1.0, 1.0) 12.28 20.4 0.018 0.182 0.359 0.376
61687ebcd2a35ffb762d1928_0hgcq 1.0 (1.0, 1.0, 1.0) 13.01 40.4 0.413 0.299 0.496 0.557
616e5ae706e970fe0aff99b6_561t0 1.0 (1.0, 1.0, 1.0) 6.15 25.2 0.624 0.453 0.548 0.497
6266a4e5846e1e41812a0432_ds50m 1.0 (1.0, 1.0, 1.0) 6.33 16.5 0.477 0.201 0.502 0.488
62e416f154e4c9e7f39d5cf7_2a9nx 1.0 (1.0, 1.0, 1.0) 6.52 9.3 0.468 0.089 0.434 0.443
5ec554706960444f4a1768de_uma91 1.0 (1.0, 1.0, 1.0) 8.58 16.4 0.248 -0.142 0.188 0.513
610aa32712b5d159232e01ca_2qade 1.0 (1.0, 1.0, 1.0) 6.85 20.9 0.523 0.403 0.548 0.556
5e3e11a36a0b8a000c609d5e_zsvqx 1.0 (1.0, 1.0, 1.0) 14.11 18.2 0.550 0.300 0.598 0.571
5ec87daedce2260008f5c0d3_w91o3 1.0 (1.0, 1.0, 1.0) 8.43 26.4 0.339 0.505 0.124 0.524
5f6aca6b9b8c12072e3b670c_vywjw 1.0 (1.0, 1.0, 1.0) 17.96 35.0 0.413 0.454 0.441 0.495
5f97a755a31f2717b0220d23_gqyj4 1.0 (1.0, 1.0, 1.0) 12.71 19.5 0.532 0.319 0.461 0.466
5fb754ca012e372845878671_xbv3b 1.0 (1.0, 1.0, 1.0) 11.34 19.4 0.514 0.510 0.464 0.512
601857c3c3f5ce0c3e5fb913_cvnls 1.0 (1.0, 1.0, 1.0) 32.80 22.6 0.431 0.200 0.529 0.487
602825b9e6f7593201d8c61b_4kogk 1.0 (1.0, 1.0, 1.0) 16.29 20.0 0.422 0.242 0.549 0.283
60c11517da9e1fd6d9a22339_wkhqh 1.0 (1.0, 1.0, 1.0) 5.98 17.4 0.394 0.247 0.512 0.497
60fe250b3984cfdf32c05860_l0zk5 1.0 (1.0, 1.0, 1.0) 11.19 25.0 0.505 0.252 0.469 0.463
613a541cf948d295c1df8752_6456u 1.0 (1.0, 1.0, 1.0) 8.09 36.3 0.495 0.351 0.427 0.344
613aef3d9041bcd28952af82_yt54b 1.0 (1.0, 1.0, 1.0) 12.64 28.9 0.349 0.345 0.540 0.570
613ffdd2bb5bf78fdfe4f6bd_nu3me 1.0 (1.0, 1.0, 1.0) 7.87 30.0 0.642 0.442 0.307 0.447
614a4cb5e867680562f258a0_dq5q6 1.0 (1.0, 1.0, 1.0) 12.30 24.1 0.385 0.345 0.607 0.601
6163af4e6672fb3862f2ae39_jugfp 1.0 (1.0, 1.0, 1.0) 12.92 26.3 0.440 0.362 0.603 0.426
629534afc0924e49e1464589_oy31o 1.0 (1.0, 1.0, 1.0) 4.98 16.6 0.569 0.154 0.462 0.439
5b7d020d4ba9cd0001e6a731_3jexa 1.0 (1.0, 1.0, 1.0) 20.05 35.1 0.541 0.184 0.514 0.405
5b94d723839c0a00010f88d9_gve2u 1.0 (1.0, 1.0, 1.0) 11.26 11.8 0.330 -0.108 0.466 0.472
5bcf309b15678a00017fcccb_mnl11 1.0 (1.0, 1.0, 1.0) 14.06 22.1 0.294 0.196 0.390 0.391
5c6f0e238e9bdd0001f6b65b_xydcz 1.0 (1.0, 1.0, 1.0) 7.98 22.6 0.495 0.020 0.421 0.395
5c97e7136825d900019b9fb8_r65ed 1.0 (1.0, 1.0, 1.0) 10.56 14.4 0.404 0.279 0.481 0.482
5cabf58293e29a0016018c30_t937s 1.0 (1.0, 1.0, 1.0) 6.91 16.4 0.560 0.143 0.372 0.438
5e1e5c3c80e02e1c36679187_jerrz 1.0 (1.0, 1.0, 1.0) 14.03 30.6 0.459 0.131 0.168 0.210
5e541f4f6567b5423b7808c5_2k0mr 1.0 (1.0, 1.0, 1.0) 11.25 36.7 0.532 0.339 0.643 0.623
5ebde9baaefecd1325ef23c7_xmfug 1.0 (1.0, 1.0, 1.0) 21.98 43.9 0.101 0.504 -0.058 0.597
5ecce2f70ecf8e0009a4296c_eau95 1.0 (1.0, 1.0, 1.0) 6.06 16.2 0.339 0.309 0.489 0.297
5f09cb729bf14505753e5bd8_em3yr 1.0 (1.0, 1.0, 1.0) 14.74 24.4 0.202 0.427 0.481 0.607
5f4469a101c96e20702a9ece_91rtn 1.0 (1.0, 1.0, 1.0) 13.51 26.9 0.495 0.562 0.517 0.445
5f516d96bf6cde3b04b94b69_w7dln 1.0 (1.0, 1.0, 1.0) 7.85 12.9 0.349 0.241 0.356 0.334
5fb40df961ccbf0360d60728_rvkp1 1.0 (1.0, 1.0, 1.0) 13.44 21.9 0.514 0.195 0.446 0.305
607de1d480f76e94ffb6e0ab_nl96p 1.0 (1.0, 1.0, 1.0) 12.01 17.1 0.257 0.462 0.542 0.405
60aa4b9356c591511cc09f5f_7096w 1.0 (1.0, 1.0, 1.0) 10.96 25.7 0.615 0.296 0.498 0.472
60d333a37d135f2ee2592457_0dw42 1.0 (1.0, 1.0, 1.0) 16.90 46.7 0.422 0.129 0.279 0.275
60eb34f117838a34a29a69d3_rxv85 1.0 (1.0, 1.0, 1.0) 11.40 38.9 0.394 0.285 0.060 0.260
611cdcaeec974368e242cbea_90orb 1.0 (1.0, 1.0, 1.0) 14.58 20.4 0.367 0.286 0.420 0.381
613a9da3c77e45388ba8a4c6_ta4o3 1.0 (1.0, 1.0, 1.0) 9.20 16.3 0.440 0.276 0.435 0.355
615025cfceb970fd5d487a5d_uz8d6 1.0 (1.0, 1.0, 1.0) 10.46 17.4 0.422 0.157 0.478 0.539
615de114da91c7b7988ddf0b_x0h13 1.0 (1.0, 1.0, 1.0) 6.81 18.3 0.523 0.302 0.393 0.397
6164cdedc4b526b72d7b96a1_py21n 1.0 (1.0, 1.0, 1.0) 13.56 28.6 0.303 0.214 0.162 0.506
616be20264dc3d95fa222d53_fycan 1.0 (1.0, 1.0, 1.0) 11.51 22.1 0.404 0.255 0.609 0.610
6303820a6d1a6fcf50e0d808_8lrn4 1.0 (1.0, 1.0, 1.0) 10.98 17.0 0.468 0.157 0.505 0.329
# kableExtra::row_spec(which(str_detect(dfsub$Participant, "613a972033d79df11a6570de")) + 1, background = "green")
p_att <- dfsub |>
  select(Participant, starts_with("Att")) |>
  pivot_longer(-Participant) |>
  # mutate(name = str_remove(name, "Cor_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  scale_color_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Score", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_time <- dfsub |>
  select(Participant, starts_with("Duration")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "Duration_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#4CAF50", "#FF9800")) +
  scale_color_manual(values = c("#4CAF50", "#FF9800")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Duration (min)", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_cor <- dfsub |>
  select(Participant, starts_with("r_")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "r_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  scale_color_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(
      angle = 45, hjust = 1,
      color = ifelse(levels(dfsub$Participant) %in% outliers, "red", ifelse(levels(dfsub$Participant) %in% outliers_partial, "orange", "black"))
    ),
    legend.position = "top"
  ) +
  labs(y = "Correlation", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

(p_att + theme(axis.text.x = element_blank())) /
  (p_time + theme(axis.text.x = element_blank())) /
  (p_cor)


df <- df |>
  filter(!Participant %in% c(outliers, outliers_partial))

Participants

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, Age, Sex, Sexual_Orientation, Ethnicity, Education, Nationality, Device_OS, starts_with("Screen"), starts_with("IPIP"), starts_with("Social_"), starts_with("FFNI_"), starts_with("GPTS_"), starts_with("IUS_"), starts_with("SelfAttractiveness"), starts_with("AI"), n_Real, Confidence_Fake, Confidence_Real) |>
  slice(1) |>
  ungroup()

The final sample included 140 participants (Mean age = 28.2, SD = 9.1, range: [19, 66]; Sex: 46.4% females, 52.9% males, 0.7% other; Education: Doctorate, 3.57%; Master, 17.86%; Bachelor, 37.14%; High School, 37.86%; Other, 3.57%; Prefer not to Say, 0.00%).

plot_distribution <- function(dfsub, what = "Age", title = what, subtitle = "", fill = "orange") {
  dfsub |>
    ggplot(aes_string(x = what)) +
    geom_density(fill = fill) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0)) +
    ggtitle(title, subtitle = subtitle) +
    theme_modern() +
    theme(
      plot.title = element_text(face = "bold", hjust = 0.5),
      plot.subtitle = element_text(face = "italic", hjust = 0.5),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
}

plot_waffle <- function(dfsub, what = "Nationality", title = what, rows = 7, size = 6) {
  # library(emojifont)
  ggwaffle::waffle_iron(dfsub, what, rows = rows) |>
    # mutate(label = emojifont::fontawesome('fa-smiley')) |>
    # mutate(label = emojifont::emoji('smiley')) |>
    ggplot(aes(x, y)) +
    geom_point(aes(color = group), shape = "square", size = size) +
    # ggwaffle::geom_waffle(color = "white") +
    # geom_point() +
    # geom_text(aes(color=group ,label=label), family='fontawesome-webfont', size=4) +
    # geom_text(aes(color=group ,label=label), family='EmojiOne', size=4) +
    coord_equal() +
    ggtitle(title) +
    labs(fill = "", color = "") +
    # scale_x_continuous(expand = c(0, 0)) +
    # scale_y_continuous(expand = c(0, 0)) +
    theme_void() +
    # ggwaffle::theme_waffle() +
    theme(plot.title = element_text(face = "bold", hjust = 0.5))
}
p1 <- estimate_density(dfsub$Age) |>
  ggplot(aes(x = x, y = y)) +
  geom_area(fill = "#FF9800") +
  labs(x = "Age", y = "") +
  theme_modern()

p2 <- plot_waffle(dfsub, "Sex") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63", "Other" = "#FF9800"))

p3 <- plot_waffle(dfsub, "Sexual_Orientation")


p4 <- plot_waffle(dfsub, "Education") +
  scale_fill_viridis_d()

p5 <- dfsub |>
  group_by(Nationality) |>
  mutate(n = n()) |>
  ungroup() |>
  mutate(Nationality = fct_reorder(Nationality, desc(n))) |>
  ggplot(aes(Nationality)) +
  geom_bar(aes(fill = Nationality)) +
  scale_fill_viridis_d(guide = "none") + 
  theme_modern() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) 

p6 <- plot_waffle(dfsub, "Ethnicity") +
  scale_fill_manual(values = c("Latino" = "#FF5722", "Asian" = "#FF9800", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Jewish" = "#9C27B0", "Mixed" = "#795548"))

p7 <- plot_waffle(dfsub, "Screen_Resolution", title = "Screen Resolution") +
  scale_fill_pizza_d() +
  guides(fill = "none")

p8 <- plot_waffle(dfsub, "Device_OS", title = "Device OS") +
  scale_fill_bluebrown_d()

# p10 <- plot_waffle(dfsub, "Screen_Refresh") +
#   scale_fill_viridis_d()

patchwork::wrap_plots(list(p1, p2, p3, p5, p4, p6))

Results

Manipulation Check

Real / Fake

# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
  mutate(Participant = fct_relevel(Participant, df |>
    group_by(Participant) |>
    summarize(Belief_Answer = mean(Belief_Answer)) |>
    ungroup() |>
    arrange(Belief_Answer) |>
    pull(Participant) |>
    as.character())) |>
  # mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
  ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
  geom_vline(xintercept = 0, linetype = "dotted") +
  scale_y_discrete(expand = c(0.02, 0)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-0.95, 0, 0.95),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d() +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "grey", color = "white") +
  ggside::scale_xsidey_continuous(expand = c(0, 0))



df |> 
  group_by(Participant, Belief) |> 
  summarize(n = n() / 108, 
            Confidence = mean(Belief_Confidence)) |> 
  pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |> 
  ungroup() |> 
  describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
## 
## Parameter       | Mean |       95% CI
## -------------------------------------
## n_Fake          | 0.44 | [0.16, 0.64]
## n_Real          | 0.56 | [0.36, 0.84]
## Confidence_Fake | 0.61 | [0.25, 1.00]
## Confidence_Real | 0.59 | [0.19, 0.99]


m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.084
## Stimulus    | 0.098

Colinearity

IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")

correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
## 
## Parameter1  |  Parameter2 |         r |        95% CI | t(15118) |         p
## ----------------------------------------------------------------------------
## Attractive  |      Beauty |      0.64 | [ 0.63, 0.65] |   103.09 | < .001***
## Attractive  | Trustworthy |      0.10 | [ 0.09, 0.12] |    12.73 | < .001***
## Attractive  |    Familiar |      0.17 | [ 0.15, 0.18] |    21.05 | < .001***
## Beauty      | Trustworthy |      0.25 | [ 0.23, 0.26] |    31.19 | < .001***
## Beauty      |    Familiar | -5.62e-03 | [-0.02, 0.01] |    -0.69 | 0.489    
## Trustworthy |    Familiar |      0.07 | [ 0.06, 0.09] |     8.88 | < .001***
## 
## p-value adjustment method: Holm (1979)
## Observations: 15120
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
  for (y in IVs) {
    if (x == y) next
    print(paste(y, "~", x))
    model <- glmmTMB::glmmTMB(as.formula(
      paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
    ),
    data = df,
    family = glmmTMB::beta_family()
    )

    # model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
    #                     random = list(Participant=~1, Stimulus=~1),
    #                     data = df,
    #                     family=mgcv::betar())

    pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
    pred$y <- y
    pred <- data_rename(pred, x, "Score")
    pred$x <- x
    preds <- rbind(preds, pred)

    dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
  }
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"

dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
  ggplot(aes(x = Score, y = Predicted)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  # geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
  geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
  scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
  scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  facet_grid(y ~ x, switch = "both") +
  theme_modern() +
  labs(title = "Collinearity in the Stimuli Ratings") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggnewscale::new_scale_fill() +
  scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")

Effect of Delay

model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
  data = df,
  family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)

m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
  data = df,
  family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
  mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))


df |>
  ggplot(aes(x = Delay, y = Real)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  geom_hline(yintercept = 0.5, linetype = "dotted") +
  # geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
  geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = pred, aes(y = Predicted), color = "red") +
  scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  theme_modern() +
  labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "#795548", color = "white") +
  ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")


hdi(df$Delay)
## 95% HDI: [1.23, 29.76]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
## 
## Delay | Participant | Stimulus | Predicted |   SE |       95% CI
## ----------------------------------------------------------------
## 0.00  |             |          |      0.58 | 0.02 | [0.53, 0.62]
## 60.00 |             |          |      0.54 | 0.03 | [0.48, 0.61]
## 
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)

parameters::parameters(model, effects="fixed", exponentiate=TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.36 0.12 (1.15, 1.62) 3.52 < .001
Delay 1.00 2.48e-03 (0.99, 1.00) -0.88 0.380
parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.85 0.09 (0.66, 1.03) 8.91 < .001
Belief (Real) -0.09 0.06 (-0.21, 0.03) -1.41 0.158
Belief (Fake) * Delay -2.48e-03 2.43e-03 (-7.25e-03, 2.29e-03) -1.02 0.309
Belief (Real) * Delay -4.93e-03 1.93e-03 (-8.71e-03, -1.15e-03) -2.56 0.011

Determinants of Reality

make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
  # Models
  m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
    data = df,
    family = "binomial"
  )
  y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
  # gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
  #                  data=df,
  #                  algorithm="sampling",
  #                  family = "bernoulli")
  # trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
  # slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
  # trend$Trend <- interpret_pd(slope$pd)
  # trend$group <- 0
  # trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))


  m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
    data = df,
    family = glmmTMB::beta_family()
  )
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  sig1 <- data.frame(x = 0.5, 
                     y = y_real[c(11, 31), "Predicted"],
                     Sex = y_real[c(11, 31), "Sex"])
  param <- parameters::parameters(m_real, effects = "fixed", keep = var)
  sig1$p <- c(min(param[str_detect(param$Parameter, sig1$Sex[1]), "p"]), min(param[str_detect(param$Parameter, sig1$Sex[2]), "p"]))
  sig1$y <- sig1$y + ifelse(sig1$Sex == "Male", 0.03, -0.03)
  sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
  
  sig2 <- data.frame(x = 0.5, 
                     y =  y_conf[c(11, 31, 51, 71), "Predicted"],
                     Sex = y_conf[c(11, 31, 51, 71), "Sex"],
                     Belief = y_conf[c(11, 31, 51, 71), "Belief"]) |> 
    arrange(Sex, Belief)
  param <- parameters::parameters(m_conf, effects = "fixed", keep = var) |> 
    arrange(Parameter)
  sig2$p <- c(min(param$p[c(1, 2)]), min(param$p[c(5, 6)]), min(param$p[c(3, 4)]), min(param$p[c(7, 8)]))
  sig2$y <- sig2$y + ifelse(sig2$Belief == "Real", 0.02, -0.02)
  sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
  
  
  
  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
    scale_fill_gradientn(colors = c("white", fill), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    # geom_point2(alpha = 0.25, size = 4, color = "black") +
    geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
    geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
    geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
    # geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
    # geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
    geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
    geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
    scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fill, color = "white") +
    ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
  var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
  var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
  var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
  var = "Familiar", fill = "#2196F3"
)

Attractiveness

parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Attractive, 2)1 8.18 3.16 (1.99, 14.38) 2.59 0.010
Sex (Male) * poly(Attractive, 2)1 12.45 3.99 (4.63, 20.27) 3.12 0.002
Sex (Female) * poly(Attractive, 2)2 4.74 2.96 (-1.06, 10.54) 1.60 0.109
Sex (Male) * poly(Attractive, 2)2 1.18 4.65 (-7.94, 10.30) 0.25 0.800
performance::performance(rez_at$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.13 0.02
performance::icc(rez_at$model_belief, by_group = TRUE)  |> 
  display()
Group ICC
Participant 0.02
Stimulus 0.09
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive")  |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Attractive, 2)1 1.42 2.22 (-2.93, 5.77) 0.64 0.522
Belief (Real) * SexFemale * poly(Attractive, 2)1 1.26 2.01 (-2.68, 5.21) 0.63 0.529
Belief (Fake) * SexMale * poly(Attractive, 2)1 1.13 3.08 (-4.90, 7.16) 0.37 0.714
Belief (Real) * SexMale * poly(Attractive, 2)1 1.32 2.55 (-3.68, 6.31) 0.52 0.606
Belief (Fake) * SexFemale * poly(Attractive, 2)2 4.85 2.16 (0.62, 9.08) 2.25 0.025
Belief (Real) * SexFemale * poly(Attractive, 2)2 3.88 1.87 (0.21, 7.55) 2.07 0.038
Belief (Fake) * SexMale * poly(Attractive, 2)2 -8.72 3.81 (-16.18, -1.25) -2.29 0.022
Belief (Real) * SexMale * poly(Attractive, 2)2 4.63 2.80 (-0.86, 10.12) 1.65 0.098

rez_at$p

Beauty

parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Beauty, 2)1 5.91 3.48 (-0.92, 12.74) 1.70 0.090
Sex (Male) * poly(Beauty, 2)1 8.86 3.91 (1.19, 16.52) 2.27 0.023
Sex (Female) * poly(Beauty, 2)2 4.42 3.13 (-1.71, 10.55) 1.41 0.158
Sex (Male) * poly(Beauty, 2)2 5.44 4.10 (-2.60, 13.47) 1.33 0.185
performance::performance(rez_gl$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.12 0.02
performance::icc(rez_gl$model_belief, by_group = TRUE)|> 
  display()
Group ICC
Participant 0.02
Stimulus 0.09
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Beauty, 2)1 0.08 2.36 (-4.56, 4.71) 0.03 0.974
Belief (Real) * SexFemale * poly(Beauty, 2)1 2.13 2.19 (-2.16, 6.42) 0.97 0.331
Belief (Fake) * SexMale * poly(Beauty, 2)1 -0.78 2.90 (-6.46, 4.90) -0.27 0.787
Belief (Real) * SexMale * poly(Beauty, 2)1 1.95 2.40 (-2.74, 6.65) 0.82 0.415
Belief (Fake) * SexFemale * poly(Beauty, 2)2 7.23 2.33 (2.65, 11.80) 3.10 0.002
Belief (Real) * SexFemale * poly(Beauty, 2)2 1.14 2.02 (-2.81, 5.09) 0.57 0.571
Belief (Fake) * SexMale * poly(Beauty, 2)2 -6.26 3.15 (-12.44, -0.08) -1.99 0.047
Belief (Real) * SexMale * poly(Beauty, 2)2 4.03 2.55 (-0.98, 9.03) 1.58 0.115

rez_gl$p

Trustworthiness

parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Trustworthy, 2)1 5.86 3.49 (-0.99, 12.71) 1.68 0.093
Sex (Male) * poly(Trustworthy, 2)1 3.17 3.78 (-4.25, 10.59) 0.84 0.402
Sex (Female) * poly(Trustworthy, 2)2 0.11 3.45 (-6.64, 6.87) 0.03 0.974
Sex (Male) * poly(Trustworthy, 2)2 1.47 3.81 (-6.00, 8.94) 0.39 0.700
performance::performance(rez_tr$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.12 0.02
performance::icc(rez_tr$model_belief, by_group = TRUE) |> 
  display()
Group ICC
Participant 0.02
Stimulus 0.09
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Trustworthy, 2)1 -1.08 2.37 (-5.72, 3.56) -0.46 0.648
Belief (Real) * SexFemale * poly(Trustworthy, 2)1 1.76 2.36 (-2.87, 6.39) 0.75 0.456
Belief (Fake) * SexMale * poly(Trustworthy, 2)1 -2.86 2.76 (-8.27, 2.56) -1.03 0.301
Belief (Real) * SexMale * poly(Trustworthy, 2)1 0.57 2.32 (-3.98, 5.12) 0.25 0.806
Belief (Fake) * SexFemale * poly(Trustworthy, 2)2 4.21 2.39 (-0.48, 8.89) 1.76 0.078
Belief (Real) * SexFemale * poly(Trustworthy, 2)2 7.46 2.29 (2.97, 11.95) 3.25 0.001
Belief (Fake) * SexMale * poly(Trustworthy, 2)2 -3.32 2.78 (-8.76, 2.12) -1.20 0.232
Belief (Real) * SexMale * poly(Trustworthy, 2)2 1.42 2.43 (-3.34, 6.19) 0.59 0.558

rez_tr$p

Familiarity

parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Familiar, 2)1 -0.33 3.53 (-7.26, 6.59) -0.09 0.925
Sex (Male) * poly(Familiar, 2)1 4.65 4.20 (-3.58, 12.89) 1.11 0.268
Sex (Female) * poly(Familiar, 2)2 0.18 3.31 (-6.32, 6.67) 0.05 0.957
Sex (Male) * poly(Familiar, 2)2 -2.74 4.53 (-11.61, 6.14) -0.60 0.546
performance::performance(rez_fa$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.12 0.02
performance::icc(rez_fa$model_belief, by_group = TRUE) |> 
  display()
Group ICC
Participant 0.02
Stimulus 0.09
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Familiar, 2)1 -0.60 2.61 (-5.71, 4.52) -0.23 0.819
Belief (Real) * SexFemale * poly(Familiar, 2)1 1.85 2.39 (-2.82, 6.53) 0.78 0.437
Belief (Fake) * SexMale * poly(Familiar, 2)1 -6.79 3.36 (-13.38, -0.21) -2.02 0.043
Belief (Real) * SexMale * poly(Familiar, 2)1 8.02 2.74 (2.66, 13.38) 2.93 0.003
Belief (Fake) * SexFemale * poly(Familiar, 2)2 2.29 2.42 (-2.46, 7.03) 0.95 0.345
Belief (Real) * SexFemale * poly(Familiar, 2)2 -3.03 2.16 (-7.26, 1.20) -1.40 0.160
Belief (Fake) * SexMale * poly(Familiar, 2)2 6.02 3.96 (-1.73, 13.77) 1.52 0.128
Belief (Real) * SexMale * poly(Familiar, 2)2 -1.10 2.71 (-6.41, 4.21) -0.40 0.686

rez_fa$p

Interaction with Self-Attractiveness

cor_test(dfsub, "SelfAttractiveness1", "SelfAttractiveness2")
## Parameter1          |          Parameter2 |    r |       95% CI | t(138) |         p
## ------------------------------------------------------------------------------------
## SelfAttractiveness1 | SelfAttractiveness2 | 0.91 | [0.87, 0.93] |  25.10 | < .001***
## 
## Observations: 140

df$Self_Attractiveness <- rowMeans(df[c("SelfAttractiveness1", "SelfAttractiveness2")])
m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Attractive, 2) * Self_Attractiveness) + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * Self Attractiveness 0.89 0.38 (0.14, 1.65) 2.33 0.020
Sex (Male) * Self Attractiveness -2.22 1.04 (-4.25, -0.18) -2.14 0.033
Sex (Female) * poly(Attractive, 2)1 * Self Attractiveness -8.74 15.31 (-38.74, 21.27) -0.57 0.568
Sex (Male) * poly(Attractive, 2)1 * Self Attractiveness 40.28 32.81 (-24.03, 104.58) 1.23 0.220
Sex (Female) * poly(Attractive, 2)2 * Self Attractiveness -1.58 11.86 (-24.83, 21.68) -0.13 0.894
Sex (Male) * poly(Attractive, 2)2 * Self Attractiveness -7.60 31.97 (-70.26, 55.06) -0.24 0.812


m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Beauty, 2) * Self_Attractiveness) + Trustworthy + Familiar + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * Self Attractiveness 0.84 0.38 (0.11, 1.58) 2.25 0.025
Sex (Male) * Self Attractiveness -1.72 1.00 (-3.67, 0.23) -1.73 0.084
Sex (Female) * poly(Beauty, 2)1 * Self Attractiveness -8.48 14.65 (-37.19, 20.23) -0.58 0.563
Sex (Male) * poly(Beauty, 2)1 * Self Attractiveness 43.84 30.23 (-15.41, 103.09) 1.45 0.147
Sex (Female) * poly(Beauty, 2)2 * Self Attractiveness 4.29 12.29 (-19.80, 28.38) 0.35 0.727
Sex (Male) * poly(Beauty, 2)2 * Self Attractiveness -12.15 29.12 (-69.22, 44.93) -0.42 0.677

Inter-Individual Correlates

plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
  y_real <- estimate_relation(m_real, at = c(var), length = 21)
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
  
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
  sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
                     p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
  sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
  sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
                     p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
                     Belief = y_conf[c(11, 31), "Belief"])
  sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
  
  # Data
  dat <- insight::get_data(m_conf) |> 
                  group_by(Participant, Belief) |> 
                  data_select(c("Participant", "Belief", var, "Belief_Confidence")) |> 
                  mean_qi(.width = 0.5) |> 
    mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
  
  
  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
    scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
    ggnewscale::new_scale_fill() +
    stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
    scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
    geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
    geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
    geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
    geom_line(data = y_real, aes(y = Predicted), size=1) +
    geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
    geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
    scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
    scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
    ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  p
}
make_correlation <- function(x, y) {
  cor <- correlation::correlation(x,
    y,
    bayesian = TRUE,
    bayesian_prior = "medium.narrow",
    sort = TRUE
  ) |>
    datawizard::data_remove(c("ROPE_Percentage"))
  cor$`BF (Spearman)` <- format_bf(
    correlation::correlation(
      x, y,
      bayesian = TRUE,
      ranktransform = TRUE,
      bayesian_prior = "medium.narrow"
    )$BF,
    name = NULL, stars = TRUE
  )
  cor |>
    arrange(desc(BF))
}

IPIP-6

f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.86 0.45 (-0.03, 1.76) 1.90 0.058
IPIP6 Extraversion -0.36 0.27 (-0.89, 0.17) -1.34 0.181
IPIP6 Conscientiousness -0.04 0.28 (-0.59, 0.50) -0.16 0.874
IPIP6 Neuroticism -0.46 0.31 (-1.06, 0.14) -1.52 0.129
IPIP6 Openness -0.09 0.32 (-0.72, 0.55) -0.27 0.785
IPIP6 HonestyHumility -0.40 0.28 (-0.95, 0.16) -1.39 0.163
IPIP6 Agreeableness 0.15 0.33 (-0.50, 0.81) 0.46 0.645


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.69 0.77 (-0.82, 2.21) 0.89 0.371
Belief (Real) 0.14 0.16 (-0.17, 0.45) 0.91 0.362
Belief (Fake) * IPIP6 Extraversion -0.25 0.46 (-1.16, 0.66) -0.54 0.588
Belief (Real) * IPIP6 Extraversion -0.36 0.46 (-1.26, 0.55) -0.77 0.441
Belief (Fake) * IPIP6 Conscientiousness -0.24 0.47 (-1.17, 0.68) -0.52 0.605
Belief (Real) * IPIP6 Conscientiousness 0.03 0.47 (-0.90, 0.95) 0.06 0.952
Belief (Fake) * IPIP6 Neuroticism -0.03 0.52 (-1.06, 0.99) -0.06 0.949
Belief (Real) * IPIP6 Neuroticism 0.06 0.52 (-0.96, 1.09) 0.12 0.908
Belief (Fake) * IPIP6 Openness 0.57 0.55 (-0.52, 1.65) 1.02 0.306
Belief (Real) * IPIP6 Openness 0.18 0.55 (-0.90, 1.27) 0.33 0.740
Belief (Fake) * IPIP6 HonestyHumility -1.26 0.49 (-2.22, -0.31) -2.59 0.010
Belief (Real) * IPIP6 HonestyHumility -1.72 0.49 (-2.68, -0.77) -3.54 < .001
Belief (Fake) * IPIP6 Agreeableness 0.94 0.57 (-0.19, 2.07) 1.64 0.102
Belief (Real) * IPIP6 Agreeableness 0.99 0.57 (-0.13, 2.12) 1.73 0.083

p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip

sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |            Parameter2 |   rho |         95% CI |       pd |               Prior |      BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.22 | [-0.36, -0.06] | 99.58%** | Beta (5.20 +- 5.20) | 10.90** |         8.29*
## Confidence_Fake |        IPIP6_Openness |  0.15 | [ 0.00,  0.30] |  97.30%* | Beta (5.20 +- 5.20) |    1.41 |          2.89
## Confidence_Fake | IPIP6_HonestyHumility | -0.14 | [-0.30,  0.01] |   95.10% | Beta (5.20 +- 5.20) |    1.08 |         0.505
## 
## Observations: 140

Narcissism

f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.15 0.32 (-0.47, 0.77) 0.47 0.638
FFNI AcclaimSeeking 0.89 0.32 (0.26, 1.52) 2.78 0.005
FFNI Arrogance -0.08 0.32 (-0.71, 0.54) -0.27 0.791
FFNI Authoritativeness -0.05 0.31 (-0.66, 0.55) -0.17 0.864
FFNI Distrust 0.37 0.28 (-0.18, 0.91) 1.31 0.190
FFNI Entitlement -0.27 0.33 (-0.92, 0.38) -0.82 0.414
FFNI Exhibitionism 0.03 0.28 (-0.52, 0.59) 0.12 0.902
FFNI Exploitativeness 0.07 0.28 (-0.47, 0.62) 0.27 0.789
FFNI GrandioseFantasies -0.18 0.23 (-0.63, 0.26) -0.80 0.421
FFNI Indifference -0.17 0.29 (-0.73, 0.39) -0.59 0.558
FFNI LackOfEmpathy 0.24 0.31 (-0.38, 0.85) 0.76 0.448
FFNI Manipulativeness -0.56 0.31 (-1.18, 0.05) -1.80 0.072
FFNI NeedForAdmiration -0.39 0.31 (-1.00, 0.22) -1.24 0.213
FFNI ReactiveAnger 0.25 0.27 (-0.29, 0.78) 0.90 0.367
FFNI Shame -0.25 0.34 (-0.92, 0.41) -0.75 0.456
FFNI ThrillSeeking 0.02 0.21 (-0.39, 0.44) 0.11 0.915


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.61 0.53 (-0.42, 1.65) 1.16 0.246
Belief (Real) -0.21 0.12 (-0.43, 0.02) -1.81 0.071
Belief (Fake) * FFNI AcclaimSeeking 1.76 0.54 (0.69, 2.82) 3.23 0.001
Belief (Real) * FFNI AcclaimSeeking 1.83 0.54 (0.77, 2.88) 3.38 < .001
Belief (Fake) * FFNI Arrogance -0.63 0.54 (-1.69, 0.43) -1.17 0.242
Belief (Real) * FFNI Arrogance -0.93 0.54 (-1.99, 0.12) -1.73 0.083
Belief (Fake) * FFNI Authoritativeness -1.69 0.52 (-2.72, -0.67) -3.24 0.001
Belief (Real) * FFNI Authoritativeness -1.76 0.52 (-2.78, -0.74) -3.39 < .001
Belief (Fake) * FFNI Distrust -0.13 0.47 (-1.06, 0.79) -0.28 0.776
Belief (Real) * FFNI Distrust 0.42 0.47 (-0.50, 1.35) 0.90 0.370
Belief (Fake) * FFNI Entitlement 0.34 0.56 (-0.75, 1.44) 0.61 0.540
Belief (Real) * FFNI Entitlement 0.81 0.56 (-0.28, 1.90) 1.45 0.147
Belief (Fake) * FFNI Exhibitionism 0.10 0.48 (-0.84, 1.03) 0.20 0.840
Belief (Real) * FFNI Exhibitionism 0.02 0.48 (-0.91, 0.96) 0.05 0.959
Belief (Fake) * FFNI Exploitativeness -0.46 0.47 (-1.38, 0.47) -0.97 0.333
Belief (Real) * FFNI Exploitativeness -0.31 0.47 (-1.24, 0.61) -0.67 0.504
Belief (Fake) * FFNI GrandioseFantasies 0.65 0.39 (-0.11, 1.41) 1.68 0.093
Belief (Real) * FFNI GrandioseFantasies 0.54 0.39 (-0.21, 1.30) 1.41 0.160
Belief (Fake) * FFNI Indifference 0.03 0.49 (-0.92, 0.99) 0.07 0.948
Belief (Real) * FFNI Indifference -0.41 0.49 (-1.36, 0.54) -0.84 0.400
Belief (Fake) * FFNI LackOfEmpathy 0.11 0.53 (-0.94, 1.15) 0.20 0.843
Belief (Real) * FFNI LackOfEmpathy 0.05 0.53 (-0.99, 1.09) 0.10 0.924
Belief (Fake) * FFNI Manipulativeness 0.64 0.53 (-0.40, 1.69) 1.22 0.224
Belief (Real) * FFNI Manipulativeness 0.61 0.53 (-0.43, 1.64) 1.15 0.250
Belief (Fake) * FFNI NeedForAdmiration -0.60 0.53 (-1.64, 0.44) -1.12 0.261
Belief (Real) * FFNI NeedForAdmiration -0.77 0.53 (-1.81, 0.27) -1.45 0.148
Belief (Fake) * FFNI ReactiveAnger 0.27 0.47 (-0.64, 1.19) 0.59 0.556
Belief (Real) * FFNI ReactiveAnger 0.21 0.46 (-0.70, 1.11) 0.45 0.656
Belief (Fake) * FFNI Shame -0.13 0.58 (-1.26, 1.00) -0.22 0.823
Belief (Real) * FFNI Shame -0.18 0.57 (-1.31, 0.94) -0.32 0.750
Belief (Fake) * FFNI ThrillSeeking -0.47 0.36 (-1.17, 0.24) -1.29 0.199
Belief (Real) * FFNI ThrillSeeking -0.34 0.36 (-1.05, 0.37) -0.94 0.348

p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1


p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF9800") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2


# p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_ThrillSeeking", fill = "#FF5722") + labs(x = "Narcissism (Thrill Seeking)")
# p_ffni3 
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |              Parameter2 |  rho |        95% CI |       pd |               Prior |    BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------------
## Confidence_Real |     FFNI_AcclaimSeeking | 0.21 | [ 0.06, 0.36] | 99.52%** | Beta (5.20 +- 5.20) | 9.18* |       29.02**
## Confidence_Fake | FFNI_GrandioseFantasies | 0.21 | [ 0.07, 0.36] | 99.67%** | Beta (5.20 +- 5.20) | 6.34* |         3.99*
## Confidence_Real | FFNI_GrandioseFantasies | 0.19 | [ 0.04, 0.34] | 99.02%** | Beta (5.20 +- 5.20) | 3.64* |         5.06*
## Confidence_Fake |     FFNI_AcclaimSeeking | 0.18 | [ 0.03, 0.34] |  98.95%* | Beta (5.20 +- 5.20) | 3.09* |         3.46*
## n_Real          |     FFNI_AcclaimSeeking | 0.15 | [-0.01, 0.30] |  97.08%* | Beta (5.20 +- 5.20) |  1.51 |          1.58
## Confidence_Fake |   FFNI_Manipulativeness | 0.14 | [-0.03, 0.28] |   95.73% | Beta (5.20 +- 5.20) |  1.14 |         0.801
## 
## Observations: 140
cor_test(dfsub, "FFNI_Authoritativeness", "IPIP6_HonestyHumility")
## Parameter1             |            Parameter2 |     r |         95% CI | t(138) |         p
## --------------------------------------------------------------------------------------------
## FFNI_Authoritativeness | IPIP6_HonestyHumility | -0.33 | [-0.47, -0.18] |  -4.16 | < .001***
## 
## Observations: 140
# cor_test(dfsub, "FFNI_ThrillSeeking", "IPIP6_HonestyHumility")

Social Anxiety

f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.24 0.14 (-0.02, 0.51) 1.80 0.072
Social Anxiety 0.29 0.40 (-0.50, 1.08) 0.71 0.476
Social Phobia -0.20 0.36 (-0.91, 0.51) -0.55 0.582


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.94 0.21 (0.53, 1.36) 4.45 < .001
Belief (Real) -0.23 0.04 (-0.31, -0.15) -5.40 < .001
Belief (Fake) * Social Anxiety -1.43 0.71 (-2.82, -0.05) -2.03 0.042
Belief (Real) * Social Anxiety -1.07 0.70 (-2.45, 0.31) -1.53 0.127
Belief (Fake) * Social Phobia 1.22 0.63 (-0.01, 2.45) 1.94 0.053
Belief (Real) * Social Phobia 0.98 0.63 (-0.25, 2.21) 1.56 0.118

# p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
# p_social 
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)

Intolerance to Uncertainty

f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.48 0.22 (0.04, 0.91) 2.14 0.033
IUS ProspectiveAnxiety -0.08 0.40 (-0.86, 0.71) -0.19 0.850
IUS InhibitoryAnxiety -0.32 0.31 (-0.92, 0.28) -1.06 0.290


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.65 0.38 (-0.08, 1.39) 1.74 0.082
Belief (Real) -0.34 0.08 (-0.50, -0.19) -4.48 < .001
Belief (Fake) * IUS ProspectiveAnxiety 0.87 0.70 (-0.50, 2.24) 1.24 0.214
Belief (Real) * IUS ProspectiveAnxiety 1.27 0.70 (-0.10, 2.63) 1.82 0.069
Belief (Fake) * IUS InhibitoryAnxiety -0.73 0.54 (-1.78, 0.32) -1.36 0.175
Belief (Real) * IUS InhibitoryAnxiety -0.93 0.54 (-1.98, 0.13) -1.73 0.084
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)

Paranoid Beliefs

f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.35 0.12 (0.12, 0.59) 2.91 0.004
GPTS Reference -0.60 0.35 (-1.29, 0.10) -1.69 0.091
GPTS Persecution 0.53 0.32 (-0.10, 1.17) 1.64 0.101


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 1.08 0.19 (0.71, 1.45) 5.77 < .001
Belief (Real) -0.24 0.04 (-0.31, -0.16) -6.25 < .001
Belief (Fake) * GPTS Reference -0.91 0.63 (-2.14, 0.32) -1.44 0.149
Belief (Real) * GPTS Reference -0.86 0.63 (-2.09, 0.37) -1.37 0.170
Belief (Fake) * GPTS Persecution 0.46 0.57 (-0.66, 1.59) 0.80 0.421
Belief (Real) * GPTS Persecution 0.61 0.57 (-0.51, 1.73) 1.06 0.288
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)

AI

rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)


efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
## 
## Variable              |   MR1    |  MR2  |   MR3    | Complexity | Uniqueness
## -----------------------------------------------------------------------------
## AI_8_Exciting         |   0.81   | 0.16  |   0.16   |    1.16    |    0.30   
## AI_4_DailyLife        |   0.77   | 0.16  |   0.16   |    1.18    |    0.36   
## AI_9_Applications     |   0.70   | 0.06  |   0.09   |    1.05    |    0.50   
## AI_7_RealisticVideos  |   0.10   | 0.79  |   0.11   |    1.07    |    0.35   
## AI_5_ImitatingReality |   0.30   | 0.64  | 2.83e-03 |    1.42    |    0.50   
## AI_1_RealisticImages  |   0.16   | 0.54  |   0.07   |    1.21    |    0.68   
## AI_3_VideosReal       |  -0.15   | 0.41  |  -0.24   |    1.92    |    0.76   
## AI_2_Unethical        |   0.18   | 0.08  |   0.73   |    1.14    |    0.43   
## AI_6_Dangerous        |   0.15   | -0.12 |   0.59   |    1.20    |    0.61   
## AI_10_FaceErrors      | 7.75e-03 | 0.03  |   0.24   |    1.04    |    0.94   
## 
## The 3 latent factors (varimax rotation) accounted for 45.62% of the total variance of the original data (MR1 = 19.22%, MR2 = 15.65%, MR3 = 10.75%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
  cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |> 
  cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.28 0.08 (0.12, 0.43) 3.49 < .001
AI Enthusiasm -0.01 0.06 (-0.13, 0.10) -0.25 0.802
AI Realness 0.07 0.06 (-0.04, 0.19) 1.23 0.218
AI Danger 0.10 0.06 (-0.03, 0.22) 1.53 0.127


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.87 0.09 (0.70, 1.05) 9.71 < .001
Belief (Real) -0.18 0.02 (-0.22, -0.15) -9.71 < .001
Belief (Fake) * AI Enthusiasm 0.30 0.10 (0.10, 0.49) 2.97 0.003
Belief (Real) * AI Enthusiasm 0.21 0.10 (0.01, 0.41) 2.10 0.036
Belief (Fake) * AI Realness 0.10 0.10 (-0.10, 0.30) 0.95 0.340
Belief (Real) * AI Realness 0.15 0.10 (-0.05, 0.35) 1.46 0.144
Belief (Fake) * AI Danger -0.07 0.11 (-0.29, 0.15) -0.65 0.514
Belief (Real) * AI Danger 0.06 0.11 (-0.16, 0.28) 0.53 0.594


p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") + 
  labs(x = "Enthusiasm about AI technology")
p_ai 

r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |    Parameter2 |  rho |        95% CI |       pd |               Prior |      BF | BF (Spearman)
## -----------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.22 | [ 0.07, 0.36] | 99.62%** | Beta (5.20 +- 5.20) | 10.76** |       13.83**
## Confidence_Real | AI_Enthusiasm | 0.17 | [ 0.02, 0.32] |  98.00%* | Beta (5.20 +- 5.20) |    2.26 |          2.42
## Confidence_Fake |   AI_Realness | 0.14 | [-0.01, 0.29] |   95.60% | Beta (5.20 +- 5.20) |    1.05 |          1.31
## 
## Observations: 140

Figures

fig1a <- (rez_at$p +
  theme(axis.text.x = element_blank()) +
  labs(x = "Attractiveness") |
  rez_gl$p +
    labs(x = "Beauty") +
    theme(
      axis.text.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
) /
  (rez_tr$p +
    labs(x = "Trustworthiness") |
    rez_fa$p +
      labs(x = "Familiarity") +
      theme(
        axis.text.y = element_blank(),
        axis.title.y = element_blank()
      )
  ) +
  plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
  plot_layout(guides = "collect") &
  theme(legend.position='top', legend.title = element_blank())

fig <- wrap_elements(fig1a) /
  wrap_elements(
    # ((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) + 
    ((p_ffni1 / p_ipip) | (p_ffni2 / p_ai)) + 
  plot_layout(guides = "collect") +
  plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
  ) +
  plot_layout(heights = c(1.1, 0.9))

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
  param <- cor_test(dfsub, x, y, bayesian = TRUE)

  # Format stat output
  r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
  CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
  CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")

  stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")

  label <- data.frame(
    x = min(dfsub[[x]], na.rm = TRUE),
    y = max(dfsub[[y]], na.rm = TRUE),
    label = stat
  )

  # Plot
  dfsub |>
    ggplot(aes_string(x = x, y = y)) +
    geom_point2(
      size = 3,
      color = fillx,
      # color = DVs[x],
      alpha = 2 / 3
    ) +
    geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
    labs(y = ylab, x = xlab) +
    geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fillx, color = "white") +
    ggside::geom_ysidedensity(fill = fill, color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))
}

p1 <- plot_correlation(dfsub,
  x = "IPIP6_HonestyHumility",
  y = "Confidence_Real",
  ylab = "Confidence that the stimulus is real",
  xlab = "Honesty-Humility",
  fillx = "#00BCD4",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p2 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p3 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is real",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p4 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p5 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p6 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_GrandioseFantasies",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Grandiose Fantasies)",
  fillx = "#FFC107",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

fig <- wrap_elements(fig1a) /
  wrap_elements(
    ((p3 / p2) | (p1 / p6) | (p4 / p5)) + 
  plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
  ) +
  plot_layout(heights = c(1.1, 0.9))

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)

References